home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / os2 / e33el2.zip / emacs / 19.33 / lisp / cal-mayan.el < prev    next >
Lisp/Scheme  |  1996-01-20  |  16KB  |  383 lines
  1. ;;; cal-mayan.el --- calendar functions for the Mayan calendars.
  2.  
  3. ;; Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
  6. ;;    Edward M. Reingold <reingold@cs.uiuc.edu>
  7. ;; Keywords: calendar
  8. ;; Human-Keywords: Mayan calendar, Maya, calendar, diary
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; This collection of functions implements the features of calendar.el and
  30. ;; diary.el that deal with the Mayan calendar.  It was written jointly by
  31.  
  32. ;;  Stewart M. Clamen                School of Computer Science
  33. ;;  clamen@cs.cmu.edu                Carnegie Mellon University
  34. ;;                                   5000 Forbes Avenue
  35. ;;                                   Pittsburgh, PA 15213
  36.  
  37. ;; and
  38.  
  39. ;;  Edward M. Reingold               Department of Computer Science
  40. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  41. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  42. ;;                                   Urbana, Illinois 61801
  43.  
  44. ;; Comments, improvements, and bug reports should be sent to Reingold.
  45.  
  46. ;; Technical details of the Mayan calendrical calculations can be found in
  47. ;; ``Calendrical Calculations, Part II: Three Historical Calendars''
  48. ;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  49. ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  50. ;; pages 383-404.
  51.  
  52. ;;; Code:
  53.  
  54. (require 'calendar)
  55.  
  56. (defconst calendar-mayan-days-before-absolute-zero 1137140
  57.   "Number of days of the Mayan calendar epoch before absolute day 0.
  58. According to the Goodman-Martinez-Thompson correlation.  This correlation is
  59. not universally accepted, as it still a subject of astro-archeological
  60. research.  Using 1232041 will give you Spinden's correlation; using
  61. 1142840 will give you Hochleitner's correlation.")
  62.  
  63. (defconst calendar-mayan-haab-at-epoch '(8 . 18)
  64.   "Mayan haab date at the epoch.")
  65.  
  66. (defconst calendar-mayan-haab-month-name-array
  67.   ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
  68.    "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])
  69.  
  70. (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  71.   "Mayan tzolkin date at the epoch.")
  72.  
  73. (defconst calendar-mayan-tzolkin-names-array
  74.   ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
  75.    "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])
  76.  
  77. (defun calendar-mayan-long-count-from-absolute (date)
  78.   "Compute the Mayan long count corresponding to the absolute DATE."
  79.   (let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
  80.     (let* ((baktun (/ long-count 144000))
  81.            (remainder (% long-count 144000))
  82.            (katun (/ remainder 7200))
  83.            (remainder (% remainder 7200))
  84.            (tun (/ remainder 360))
  85.            (remainder (% remainder 360))
  86.            (uinal (/ remainder 20))
  87.            (kin (% remainder 20)))
  88.       (list baktun katun tun uinal kin))))
  89.  
  90. (defun calendar-mayan-long-count-to-string (mayan-long-count)
  91.   "Convert MAYAN-LONG-COUNT into traditional written form."
  92.   (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
  93.  
  94. (defun calendar-string-to-mayan-long-count (str)
  95.   "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums."
  96.   (let ((rlc nil)
  97.         (c (length str))
  98.         (cc 0))
  99.     (condition-case condition
  100.         (progn
  101.           (while (< cc c)
  102.         (let* ((start (string-match "[0-9]+" str cc))
  103.            (end (match-end 0))
  104.            datum)
  105.           (setq datum (read (substring str start end)))
  106.           (setq rlc (cons datum rlc))
  107.           (setq cc end)))
  108.           (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
  109.       (invalid-read-syntax nil))
  110.     (reverse rlc)))
  111.  
  112. (defun calendar-mayan-haab-from-absolute (date)
  113.   "Convert absolute DATE into a Mayan haab date (a pair)."
  114.   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  115.          (day-of-haab
  116.           (% (+ long-count
  117.                 (car calendar-mayan-haab-at-epoch)
  118.                 (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
  119.              365))
  120.          (day (% day-of-haab 20))
  121.          (month (1+ (/ day-of-haab 20))))
  122.     (cons day month)))
  123.  
  124. (defun calendar-mayan-haab-difference (date1 date2)
  125.   "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
  126.   (mod (+ (* 20 (- (cdr date2) (cdr date1)))
  127.       (- (car date2) (car date1)))
  128.        365))
  129.  
  130. (defun calendar-mayan-haab-on-or-before (haab-date date)
  131.   "Absolute date of latest HAAB-DATE on or before absolute DATE."
  132.   (- date
  133.      (% (- date
  134.        (calendar-mayan-haab-difference
  135.         (calendar-mayan-haab-from-absolute 0) haab-date))
  136.     365)))
  137.  
  138. (defun calendar-next-haab-date (haab-date &optional noecho)
  139.   "Move cursor to next instance of Mayan HAAB-DATE. 
  140. Echo Mayan date if NOECHO is t."
  141.   (interactive (list (calendar-read-mayan-haab-date)))
  142.   (calendar-goto-date
  143.    (calendar-gregorian-from-absolute
  144.     (calendar-mayan-haab-on-or-before
  145.      haab-date
  146.      (+ 365
  147.         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  148.   (or noecho (calendar-print-mayan-date)))
  149.  
  150. (defun calendar-previous-haab-date (haab-date &optional noecho)
  151.   "Move cursor to previous instance of Mayan HAAB-DATE. 
  152. Echo Mayan date if NOECHO is t."
  153.   (interactive (list (calendar-read-mayan-haab-date)))
  154.   (calendar-goto-date
  155.    (calendar-gregorian-from-absolute
  156.     (calendar-mayan-haab-on-or-before
  157.      haab-date
  158.      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  159.   (or noecho (calendar-print-mayan-date)))
  160.  
  161. (defun calendar-mayan-haab-to-string (haab)
  162.   "Convert Mayan haab date (a pair) into its traditional written form."
  163.   (let ((month (cdr haab))
  164.         (day (car haab)))
  165.   ;; 19th month consists of 5 special days
  166.   (if (= month 19)
  167.       (format "%d Uayeb" day)
  168.     (format "%d %s"
  169.             day
  170.             (aref calendar-mayan-haab-month-name-array (1- month))))))
  171.  
  172. (defun calendar-mayan-tzolkin-from-absolute (date)
  173.   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
  174.   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  175.          (day (calendar-mod
  176.                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
  177.                13))
  178.          (name (calendar-mod
  179.                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
  180.                 20)))
  181.     (cons day name)))
  182.  
  183. (defun calendar-mayan-tzolkin-difference (date1 date2)
  184.   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
  185.   (let ((number-difference (- (car date2) (car date1)))
  186.         (name-difference (- (cdr date2) (cdr date1))))
  187.     (mod (+ number-difference
  188.         (* 13 (mod (* 3 (- number-difference name-difference))
  189.                20)))
  190.      260)))
  191.  
  192. (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
  193.   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
  194.   (- date
  195.      (% (- date (calendar-mayan-tzolkin-difference
  196.          (calendar-mayan-tzolkin-from-absolute 0)
  197.          tzolkin-date))
  198.     260)))
  199.  
  200. (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
  201.   "Move cursor to next instance of Mayan TZOLKIN-DATE. 
  202. Echo Mayan date if NOECHO is t."
  203.   (interactive (list (calendar-read-mayan-tzolkin-date)))
  204.   (calendar-goto-date
  205.    (calendar-gregorian-from-absolute
  206.     (calendar-mayan-tzolkin-on-or-before
  207.      tzolkin-